home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 11 / CU Amiga Magazine's Super CD-ROM 11 (1997)(EMAP Images)(GB)(Track 1 of 3)[!][issue 1997-06].iso / cucd / programming / oberonv4 / source / system / calc.mod (.txt) < prev    next >
Oberon Text  |  1995-12-24  |  12KB  |  349 lines
  1. Syntax10.Scn.Fnt
  2. Syntax10i.Scn.Fnt
  3. Syntax10b.Scn.Fnt
  4. MODULE Calc;    (*CAS 28.9.93*)
  5.     IMPORT
  6.         MathL, Texts, Oberon;
  7.     CONST
  8.         Version = "Calc / cas 28.9.93";
  9.         End = 7;    (*new scanner symbol*)
  10.         Eps = 1.0D-9; Eps0 = 0.5D-9;
  11.     TYPE
  12.         Symbol = POINTER TO SymbolDesc;
  13.         SymbolDesc = RECORD
  14.             name: ARRAY 32 OF CHAR;
  15.             funct: BOOLEAN;
  16.             val: LONGREAL;
  17.             next: Symbol
  18.         END;
  19.         lastTime: LONGINT;
  20.         W: Texts.Writer;
  21.         S: Texts.Scanner;
  22.         syms: Symbol;
  23.     (** expression syntax:
  24.         Expr = Term {AddOp Term}.
  25.         Term = Factor {MulOp Factor}.
  26.         Factor = Atom {PowOp Atom}.
  27.         Atom = Number | Functor Atom | ident | "(" Expr ")".
  28.         PowOp = "^".
  29.         MulOp = "*" | "/" | "%" | "<" | ">".    -- % modulo, < shift left, > shift right
  30.         AddOp = ["+" | "-"].    -- no add op: addition(!)
  31.         Number = (digit {digit}) | (digit {hexDigit} "H") | (digit {hexDigit} "X") | (""" char """).
  32.         Functor = "arccos" | "arcsin" | "arctan" | "cos" | "entier" | "exp" | "ln" | "short" | "sign" | "sin" | "sqrt" | "tan".
  33.     PROCEDURE err;
  34.     BEGIN S.class := Texts.Inval
  35.     END err;
  36.     PROCEDURE sign (n: LONGREAL): LONGREAL;
  37.     BEGIN
  38.         IF n < 0 THEN RETURN -1
  39.         ELSIF n = 0 THEN RETURN 0
  40.         ELSE RETURN 1 END
  41.     END sign;
  42.     PROCEDURE short (n: LONGREAL): REAL;
  43.     BEGIN RETURN SHORT(n + Eps0)
  44.     END short;
  45.     PROCEDURE entier (n: LONGREAL): LONGINT;
  46.     BEGIN RETURN ENTIER(n + Eps0)
  47.     END entier;
  48.     PROCEDURE sin (n: LONGREAL): LONGREAL;
  49.     BEGIN RETURN MathL.sin(n)
  50.     END sin;
  51.     PROCEDURE cos (n: LONGREAL): LONGREAL;
  52.     BEGIN RETURN MathL.cos(n)
  53.     END cos;
  54.     PROCEDURE tan (n: LONGREAL): LONGREAL;
  55.         VAR x: LONGREAL;
  56.     BEGIN x := MathL.cos(n);
  57.         IF x # 0 THEN RETURN MathL.sin(n) / x ELSE err; RETURN 1 END
  58.     END tan;
  59.     PROCEDURE arcsin (n: LONGREAL): LONGREAL;
  60.         VAR x: LONGREAL;
  61.     BEGIN x := MathL.sqrt(1 - n * n);
  62.         IF x # 0 THEN RETURN MathL.arctan(n / x) ELSE err; RETURN 1 END
  63.     END arcsin;
  64.     PROCEDURE arccos (n: LONGREAL): LONGREAL;
  65.     BEGIN RETURN MathL.pi / 2 - arcsin(n)
  66.     END arccos;
  67.     PROCEDURE arctan (n: LONGREAL): LONGREAL;
  68.     BEGIN RETURN MathL.arctan(n)
  69.     END arctan;
  70.     PROCEDURE exp (n: LONGREAL): LONGREAL;
  71.     BEGIN RETURN MathL.exp(n)
  72.     END exp;
  73.     PROCEDURE ln (n: LONGREAL): LONGREAL;
  74.     BEGIN
  75.         IF n > 0 THEN RETURN MathL.ln(n) ELSE err; RETURN 1 END
  76.     END ln;
  77.     PROCEDURE sqrt (n: LONGREAL): LONGREAL;
  78.     BEGIN
  79.         IF n >= 0 THEN RETURN MathL.sqrt(n) ELSE err; RETURN 1 END
  80.     END sqrt;
  81.     PROCEDURE Ch (ch: CHAR);
  82.     BEGIN Texts.Write(W, ch)
  83.     END Ch;
  84.     PROCEDURE Str (s: ARRAY OF CHAR);
  85.     BEGIN Texts.WriteString(W, s)
  86.     END Str;
  87.     PROCEDURE WrHex (n: LONGREAL);
  88.         VAR x, y: LONGINT; i: INTEGER;
  89.             a: ARRAY 10 OF CHAR;
  90.     BEGIN x := entier(n);
  91.         i := 0; Texts.Write(W, " ");
  92.         REPEAT y := x MOD 10H;
  93.             IF y < 10 THEN a[i] := CHR(y + 30H) ELSE a[i] := CHR(y + 37H) END;
  94.             x := x DIV 10H; INC(i)
  95.         UNTIL i = 8;
  96.         REPEAT DEC(i) UNTIL (i = 0) OR (a[i] # "0");
  97.         IF a[i] >= "A" THEN Texts.Write(W, "0") END;
  98.         WHILE i >= 0 DO Texts.Write(W, a[i]); DEC(i) END;
  99.         Texts.Write(W, "H")
  100.     END WrHex;
  101.     PROCEDURE WrInt (n: LONGREAL);
  102.     BEGIN Texts.Write(W, " "); Texts.WriteInt(W, entier(n), 0)
  103.     END WrInt;
  104.     PROCEDURE WrChar (n: LONGREAL);
  105.         VAR ch: CHAR;
  106.     BEGIN ch := CHR(entier(n));
  107.         IF (" " <= ch) & (ch < 7FX) OR (80X <= ch) & (ch < 0A0X) THEN Ch(" "); Ch(22X); Ch(ch); Ch(22X)
  108.         ELSE WrHex(ORD(ch))
  109.         END
  110.     END WrChar;
  111.     PROCEDURE WrReal (n: LONGREAL);
  112.         VAR x: LONGREAL;
  113.     BEGIN
  114.         IF (MIN(LONGINT) <= n) & (n <= MAX(LONGINT)) THEN x := ABS(n - ENTIER(SHORT(n)));
  115.             IF x < Eps THEN WrInt(n); RETURN END
  116.         END;
  117.         IF (MIN(REAL) <= n) & (n <= MAX(REAL)) THEN x := ABS(n - SHORT(n));
  118.             IF x < Eps THEN
  119.                 IF (-10000 < n) & (n < 10000) THEN Texts.WriteRealFix(W, short(n), 0, 6)
  120.                 ELSE Texts.WriteReal(W, short(n), 14)
  121.                 END;
  122.                 RETURN
  123.             END
  124.         END;
  125.         Texts.WriteLongReal(W, n, 23)
  126.     END WrReal;
  127.     PROCEDURE WrValue (n: LONGREAL);
  128.         VAR x: LONGREAL;
  129.     BEGIN
  130.         Str(" ="); WrReal(n);
  131.         IF (MIN(LONGINT) <= n) & (n <= MAX(LONGINT)) THEN x := ABS(n - ENTIER(SHORT(n)));
  132.             IF x < Eps THEN Str(" ="); WrHex(n); Str(" ="); WrInt(n);
  133.                 IF (0 <= n) & (n < 256) & (entier(n) = n) THEN Str(" ="); WrChar(n) END
  134.             END
  135.         END
  136.     END WrValue;
  137.     PROCEDURE Ln;
  138.     BEGIN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
  139.     END Ln;
  140.     PROCEDURE Scan (VAR S: Texts.Scanner);
  141.         PROCEDURE hex (n: LONGINT): LONGINT;
  142.             VAR x, i: LONGINT; d: ARRAY 8 OF LONGINT;
  143.         BEGIN x := 0; i := 0;
  144.             REPEAT d[i] := n MOD 10; n := n DIV 10; INC(i) UNTIL n = 0;
  145.             WHILE i > 0 DO DEC(i); x := 16*x + d[i] END;
  146.             RETURN x
  147.         END hex;
  148.     BEGIN
  149.         IF S.eot THEN S.class := End
  150.         ELSIF S.nextCh = "/" THEN S.class := Texts.Char; S.c := "/"; Texts.Read(S, S.nextCh)
  151.         ELSE Texts.Scan(S)
  152.         END;
  153.         IF S.line # 0 THEN S.class := End END;
  154.         IF (S.class = Texts.Char) & (S.c = " ") THEN S.c := "-"
  155.         ELSIF (S.class = Texts.String) & (S.len = 2) THEN S.i := ORD(S.s[0]); S.class := Texts.Int
  156.         ELSIF (S.class = Texts.Int) & (S.nextCh = "X") THEN S.i := hex(S.i);
  157.             Texts.Read(S, S.nextCh)
  158.         END
  159.     END Scan;
  160.     PROCEDURE OpenScanner (VAR S: Texts.Scanner);
  161.         VAR text: Texts.Text; beg, end, time: LONGINT;
  162.     BEGIN
  163.         Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Scan(S);
  164.         IF (S.class = Texts.Char) & (S.c = "^") & (S.line = 0) THEN
  165.             Oberon.GetSelection(text, beg, end, time);
  166.             IF time >= lastTime THEN lastTime := time;
  167.                 Texts.OpenScanner(S, text, beg); Scan(S)
  168.             END
  169.         END;
  170.         IF S.line # 0 THEN S.class := Texts.Inval END
  171.     END OpenScanner;
  172.     PROCEDURE FindIdent (name: ARRAY OF CHAR; insert: BOOLEAN; VAR val: LONGREAL);
  173.         VAR s: Symbol;
  174.     BEGIN s := syms;
  175.         WHILE (s # NIL) & ((s.name # name) OR s.funct) DO s := s.next END;
  176.         IF insert THEN
  177.             IF s = NIL THEN NEW(s); s.next := syms; syms := s END;
  178.             COPY(name, s.name); s.funct := FALSE; s.val := val
  179.         ELSIF s # NIL THEN val := s.val
  180.         ELSE S.class := Texts.Inval
  181.         END
  182.     END FindIdent;
  183.     PROCEDURE FindFunct (name: ARRAY OF CHAR; insert: BOOLEAN; VAR sym: Symbol);
  184.         VAR s: Symbol;
  185.     BEGIN s := syms;
  186.         WHILE (s # NIL) & ((s.name # name) OR ~s.funct) DO s := s.next END;
  187.         IF insert THEN
  188.             IF s = NIL THEN s := sym; s.next := syms; syms := sym END;
  189.             COPY(name, s.name); s.funct := TRUE; s.val := 0
  190.         ELSIF s # NIL THEN sym := s
  191.         ELSE sym := NIL
  192.         END
  193.     END FindFunct;
  194.     PROCEDURE InitSyms;
  195.         VAR s: Symbol; n: LONGREAL; name: ARRAY 2 OF CHAR;
  196.     BEGIN name[1] := 0X;
  197.         name[0] := "e"; n := MathL.e; FindIdent(name, TRUE, n);
  198.         n := MathL.pi; FindIdent("pi", TRUE, n);
  199.         n := 0;
  200.         NEW(s); FindFunct("arctan", TRUE, s);
  201.         NEW(s); FindFunct("arccos", TRUE, s);
  202.         NEW(s); FindFunct("arcsin", TRUE, s);
  203.         NEW(s); FindFunct("cos", TRUE, s);
  204.         NEW(s); FindFunct("entier", TRUE, s);
  205.         NEW(s); FindFunct("exp", TRUE, s);
  206.         NEW(s); FindFunct("ln", TRUE, s);
  207.         NEW(s); FindFunct("short", TRUE, s);
  208.         NEW(s); FindFunct("sign", TRUE, s);
  209.         NEW(s); FindFunct("sin", TRUE, s);
  210.         NEW(s); FindFunct("sqrt", TRUE, s);
  211.         NEW(s); FindFunct("tan", TRUE, s)
  212.     END InitSyms;
  213.     PROCEDURE^ Expr (VAR n: LONGREAL);
  214.     PROCEDURE Functor (sym: Symbol; VAR n: LONGREAL);
  215.     BEGIN
  216.         IF sym.name = "arcsin" THEN n := arcsin(n)
  217.         ELSIF sym.name = "arccos" THEN n := arccos(n)
  218.         ELSIF sym.name = "arctan" THEN n := arctan(n)
  219.         ELSIF sym.name = "cos" THEN n := cos(n)
  220.         ELSIF sym.name = "exp" THEN n := exp(n)
  221.         ELSIF sym.name = "entier" THEN n := entier(n)
  222.         ELSIF sym.name = "ln" THEN n := ln(n)
  223.         ELSIF sym.name = "short" THEN n := short(n)
  224.         ELSIF sym.name = "sign" THEN n := sign(n)
  225.         ELSIF sym.name = "sin" THEN n := sin(n)
  226.         ELSIF sym.name = "sqrt" THEN n := sqrt(n)
  227.         ELSIF sym.name = "tan" THEN n := tan(n)
  228.         END
  229.     END Functor;
  230.     PROCEDURE Atom (VAR n: LONGREAL);
  231.         VAR sym: Symbol;
  232.     BEGIN
  233.         IF S.class = Texts.Int THEN n := S.i; Scan(S)
  234.         ELSIF S.class = Texts.Real THEN n := S.x; Scan(S)
  235.         ELSIF S.class = Texts.LongReal THEN n := S.y; Scan(S)
  236.         ELSIF S.class = Texts.Name THEN FindFunct(S.s, FALSE, sym);
  237.             IF sym # NIL THEN Scan(S); Atom(n);
  238.                 IF S.class # Texts.Inval THEN Functor(sym, n) END
  239.             ELSE FindIdent(S.s, FALSE, n);
  240.                 IF S.class # Texts.Inval THEN Scan(S) END
  241.             END
  242.         ELSIF (S.class = Texts.Char) & (S.c = "(") THEN Scan(S);
  243.             Expr(n);
  244.             IF (S.class = Texts.Char) & (S.c = ")") THEN Scan(S)
  245.             ELSE S.class := Texts.Inval
  246.             END
  247.         ELSE S.class := Texts.Inval
  248.         END
  249.     END Atom;
  250.     PROCEDURE Factor (VAR n: LONGREAL);
  251.         VAR x: LONGREAL;
  252.     BEGIN Atom(n);
  253.         WHILE (S.class = Texts.Char) & (S.c = "^") DO
  254.             Scan(S); Factor(x);
  255.             n := sign(n) * MathL.exp(MathL.ln(ABS(n)) * x)
  256.         END
  257.     END Factor;
  258.     PROCEDURE Term (VAR n: LONGREAL);
  259.         VAR x: LONGREAL; op: CHAR;
  260.     BEGIN Factor(n);
  261.         WHILE (S.class = Texts.Char)
  262.         & ((S.c = "*") OR (S.c = "/") OR (S.c = "%") OR (S.c = ">") OR (S.c = "<")) DO
  263.             op := S.c; Scan(S); Factor(x);
  264.             CASE op OF
  265.                 "*": n := n * x
  266.             |   "/": IF x # 0 THEN n := n / x ELSE err END
  267.             |   "%": IF x # 0 THEN n := entier(n) MOD entier(x) ELSE err END
  268.             |   "<": n := ASH(entier(n), entier(x))
  269.             |   ">": n := ASH(entier(n), -entier(x))
  270.             END
  271.         END
  272.     END Term;
  273.     PROCEDURE Expr (VAR n: LONGREAL);
  274.         VAR x: LONGREAL; op: CHAR;
  275.     BEGIN Term(n);
  276.         WHILE (S.class = Texts.Char) & ((S.c = "+") OR (S.c = "-")) OR (S.class = Texts.Int) DO
  277.             IF S.class = Texts.Char THEN op := S.c; Scan(S) ELSE op := "+" END;
  278.             Term(x);
  279.             CASE op OF
  280.                 "+": n := n + x
  281.             |   "-": n := n - x
  282.             END
  283.         END
  284.     END Expr;
  285.     PROCEDURE Hex*;    (** expr **)
  286.         VAR n: LONGREAL;
  287.     BEGIN Str("Calc.Hex"); OpenScanner(S); Expr(n);
  288.         IF S.class # Texts.Inval THEN WrHex(n) ELSE Str(" failed: bad argument") END;
  289.     END Hex;
  290.     PROCEDURE Dec*;    (** expr **)
  291.         VAR n: LONGREAL;
  292.     BEGIN Str("Calc.Dec"); OpenScanner(S); Expr(n);
  293.         IF S.class # Texts.Inval THEN WrInt(n) ELSE Str(" failed: bad argument") END;
  294.     END Dec;
  295.     PROCEDURE Real*;    (** expr **)
  296.         VAR n: LONGREAL;
  297.     BEGIN Str("Calc.Real"); OpenScanner(S); Expr(n);
  298.         IF S.class # Texts.Inval THEN WrReal(n) ELSE Str(" failed: bad argument") END;
  299.     END Real;
  300.     PROCEDURE Char*;    (** expr **)
  301.         VAR n: LONGREAL;
  302.     BEGIN Str("Calc.Char"); OpenScanner(S); Expr(n);
  303.         IF S.class # Texts.Inval THEN
  304.             IF (0 <= n) & (n < 256) THEN WrChar(n)
  305.             ELSE Str(" failed: not a character code")
  306.             END
  307.         ELSE Str(" failed: bad argument")
  308.         END;
  309.     END Char;
  310.     PROCEDURE Set*;    (** {name ":=" expr} "~" **)
  311.         VAR
  312.             n: LONGREAL;
  313.             name: ARRAY 32 OF CHAR;
  314.     BEGIN Str("Calc.Set"); Ln;
  315.         OpenScanner(S);
  316.         WHILE S.class = Texts.Name DO COPY(S.s, name); Scan(S);
  317.             IF (S.class = Texts.Name) & (S.s = ":") & (S.nextCh = "=") THEN
  318.                 Scan(S); Scan(S); Expr(n)
  319.             ELSE S.class := Texts.Inval
  320.             END;
  321.             IF S.class # Texts.Inval THEN FindIdent(name, TRUE, n);
  322.                 IF S.class # Texts.Inval THEN Str("  "); Str(name); WrValue(n); Ln END
  323.             END
  324.         END;
  325.         IF S.class = Texts.Inval THEN Str("  failed: bad argument") END
  326.     END Set;
  327.     PROCEDURE List*;
  328.         VAR s: Symbol;
  329.     BEGIN Str("Calc.List"); Ln;
  330.         s := syms;
  331.         WHILE s # NIL DO
  332.             IF s.funct THEN Str("  "); Str(s.name) END;
  333.             s := s.next
  334.         END;
  335.         Ln;
  336.         s := syms;
  337.         WHILE s # NIL DO
  338.             IF ~s.funct THEN Str("  "); Str(s.name); WrValue(s.val); Ln END;
  339.             s := s.next
  340.         END
  341.     END List;
  342.     PROCEDURE Reset*;
  343.     BEGIN Str("Calc.Reset"); Ln; syms := NIL; InitSyms
  344.     END Reset;
  345. BEGIN Texts.OpenWriter(W); Texts.WriteString(W, Version); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
  346.     lastTime := 0; syms := NIL; InitSyms
  347. END Calc.
  348. System.Free Calc ~
  349.